Option Compare Database
Option Explicit

Sub PopulateWordTable()
Dim aWordApp As Word.Application
Dim aRange As Word.Range, aTable As Word.Table
Dim aCell As Word.Cell, iCol As Integer
Dim rst1 As New Recordset, iRow As Integer

'Open the PAPERS table
With rst1
     .ActiveConnection = CurrentProject.Connection
     .Open "PAPERS", , adOpenKeyset, adLockOptimistic, adCmdTable
End With

'Create an instance of a Word application
Set aWordApp = CreateObject("Word.Application")

'Add a document to the application and a table to the document
'Specify # of rows to be one more than # of rows in PAPERS table
aWordApp.Documents.Add
Set aRange = aWordApp.ActiveDocument.Range(0, 0)
aWordApp.ActiveDocument.Tables.Add Range:=aRange, _
     NumRows:=rst1.RecordCount + 1, NumColumns:=3
     
'Transfer table column headings
With aWordApp.ActiveDocument.Tables(1).Rows(1)
     .Cells(1).Range.Text = rst1.Fields(0).Name
     .Cells(2).Range.Text = rst1.Fields(2).Name
     .Cells(3).Range.Text = rst1.Fields(3).Name
End With

'Insert paper number, title, and author from PAPERS table
For iRow = 2 To aWordApp.ActiveDocument.Tables(1).Rows.Count
     iCol = 0
     For Each aCell In _
          aWordApp.ActiveDocument.Tables(1).Rows(iRow).Cells
          aCell.Range.Text = IIf(IsNull(rst1.Fields(iCol)), _
               "", rst1.Fields(iCol))
          If iCol = 0 Then
               iCol = iCol + 2
          Else
               iCol = iCol + 1
          End If
     Next aCell
     rst1.MoveNext
Next iRow

'Reformat column widths
aWordApp.ActiveDocument.Tables(1).AutoFitBehavior wdAutoFitContent

'Make Word visible
aWordApp.Visible = True
     
End Sub
